home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / comp-sf.scm < prev    next >
Text File  |  1992-09-05  |  9KB  |  256 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: comp-sf.scm,v 1.6 1992/09/05 16:05:03 jmiller Exp $
  39.  
  40. ;;;; More of the compiler: simple special forms
  41. ;;;;
  42. ;;;; SET!, COND, CASE, SELECT, FOR
  43.  
  44. ;;; SET!
  45.  
  46. (define (compile-SET!-form
  47.      e mod-vars bound-vars compiler multiple-values? continue)
  48.   (must-be-list-of-length e 2 "SET! -- invalid syntax")
  49.   (let ((place (car e))
  50.     (value (cadr e)))
  51.     (compiler value mod-vars bound-vars #F
  52.      (lambda (value-code module-vars)
  53.        (cond
  54.     ((variable-name? place)
  55.      (let ((name (variable->name place)))
  56.        (continue
  57.         `(LET ((!SAVED-VALUE ,value-code))
  58.            (SET! ,name !SAVED-VALUE)
  59.            !SAVED-VALUE)
  60.         (add-variable name bound-vars module-vars))))
  61.     ((list? place)
  62.      (compile-forms `((SETTER ,(car place)) ,@(cdr place))
  63.        module-vars bound-vars compiler #F
  64.        (lambda (subform-codes mod-vars)
  65.          (continue `(LET ((!SAVED-VALUE ,value-code))
  66.               (DYLAN::APPLY
  67.                ,multiple-values?
  68.                ,@(map (lambda (x) `(LAMBDA () ,x)) subform-codes)
  69.                (LAMBDA () !SAVED-VALUE))
  70.               !SAVED-VALUE)
  71.                mod-vars))))
  72.     (else (dylan::error "SET! -- bad place specification")))))))
  73.  
  74. ;;; COND
  75.  
  76. (define (compile-COND-form
  77.      clauses module-vars bound-vars compiler
  78.      multiple-values? continue)
  79.   (define (compile-clause clause mod-vars continue)
  80.     (must-be-list-of-at-least-length clause 1 "COND -- bad clause syntax")
  81.     (let ((predicate (car clause))
  82.       (consequents (cdr clause)))
  83.       (compiler predicate mod-vars bound-vars #F
  84.     (lambda (pred-code mod-vars)
  85.       (if (null? consequents)
  86.           (continue `(,pred-code) mod-vars)
  87.           (compile-forms consequents mod-vars bound-vars
  88.                  compiler multiple-values?
  89.             (lambda (consequent-code mod-vars)
  90.           (continue `(,pred-code ,@consequent-code) mod-vars))))))))
  91.   (define (compile-remaining-clauses clauses mod-vars continue)
  92.     (if (null? clauses)
  93.     (continue `((ELSE ,compiled-sharp-f)) mod-vars)
  94.     (compile-clause (car clauses) mod-vars
  95.           (lambda (this-clause-code mod-vars)
  96.         (compile-remaining-clauses (cdr clauses) mod-vars
  97.           (lambda (rest-clauses-code mod-vars)
  98.         (continue
  99.          (cons this-clause-code rest-clauses-code)
  100.          mod-vars)))))))
  101.   (if (not (list? clauses)) (dylan::error "COND -- bad syntax" clauses))
  102.   (compile-remaining-clauses clauses module-vars
  103.     (lambda (clause-code mod-vars)
  104.       (continue `(COND ,@clause-code) mod-vars))))
  105.  
  106. ;;; CASE
  107.  
  108. (define (compile-CASE-form
  109.      e module-vars bound-vars compiler multiple-values? continue)
  110.   (must-be-list-of-at-least-length e 1 "CASE -- bad syntax")
  111.   (let ((Have-default? #F))
  112.     (define (compile-clause clause mod-vars continue)
  113.       (if (not (pair? clause))
  114.       (dylan::error "CASE -- bad clause syntax" clause))
  115.       (let ((match-list (car clause))
  116.         (consequents (cdr clause)))
  117.     (let ((new-match
  118.            (cond ((or (eq? match-list 'else:) (eq? match-list #T))
  119.               (set! Have-Default? #T)
  120.               'else)
  121.              ((list? match-list) match-list)
  122.              (else (dylan::error "CASE -- bad match list" clause)))))
  123.       (if (null? consequents)
  124.           (continue `(,new-match ,compiled-sharp-f) mod-vars)
  125.           (compile-forms consequents mod-vars
  126.                  bound-vars compiler multiple-values?
  127.         (lambda (consequent-code mod-vars)
  128.           (continue `(,new-match ,@consequent-code)
  129.                 mod-vars)))))))
  130.     (let ((expr (car e)))
  131.       (compiler expr module-vars bound-vars #F
  132.     (lambda (expr-code mod-vars)
  133.       (let loop ((clauses (cdr e))
  134.              (compiled '())
  135.              (mod-vars mod-vars))
  136.         (if (null? clauses)
  137.         (continue
  138.          `(CASE ,expr-code
  139.             ,@(reverse compiled)
  140.             ,@(if Have-Default?
  141.               '()
  142.               `((ELSE
  143.                 (DYLAN-CALL DYLAN:ERROR
  144.                     "CASE -- no matches" ',e)))))
  145.          mod-vars)
  146.         (if Have-Default?
  147.             (dylan::error "CASE -- else isn't last clause" e)
  148.             (compile-clause (car clauses) mod-vars
  149.               (lambda (code mod-vars)
  150.             (loop (cdr clauses)
  151.                   (cons code compiled)
  152.                   mod-vars)))))))))))
  153.  
  154. ;;; SELECT
  155.  
  156. (define (compile-SELECT-form
  157.      e module-vars bound-vars compiler multiple-values? continue)
  158.   (must-be-list-of-at-least-length e 2 "SELECT -- bad syntax")
  159.   (let ((Have-Default? #F))
  160.     (define (compile-clause clause mod-vars continue)
  161.       (if (not (pair? clause))
  162.       (dylan::error "SELECT -- bad clause syntax" clause))
  163.       (let ((match-list (car clause))
  164.         (consequents (cdr clause)))
  165.     (let ((new-match
  166.            (cond ((or (eq? match-list 'else:)
  167.               (eq? match-list #T))
  168.               (set! Have-Default? #T)
  169.               'else)
  170.              ((list? match-list)
  171.               (compile-forms
  172.                match-list mod-vars bound-vars compiler #F
  173.                (lambda (matches new-mod-vars)
  174.              (set! mod-vars new-mod-vars)
  175.              `(OR ,@(map
  176.                  (lambda (code)
  177.                    `(DYLAN::APPLY
  178.                      #F
  179.                      (LAMBDA () !SELECT-TEST)
  180.                      (LAMBDA () !SELECT-TARGET)
  181.                      (LAMBDA () ,code)))
  182.                  matches)))))
  183.              (else (dylan::error "SELECT -- bad match list" clause)))))
  184.       (if (null? consequents)
  185.           (continue `(,new-match ,compiled-sharp-f) mod-vars)
  186.           (compile-forms consequents mod-vars bound-vars
  187.                  compiler multiple-values?
  188.         (lambda (consequent-code mod-vars)
  189.           (continue `(,new-match ,@consequent-code)
  190.                 mod-vars)))))))
  191.     (let ((target (car e))
  192.       (test (cadr e)))
  193.       (compile-forms (list target test) module-vars bound-vars compiler #F
  194.     (lambda (expr-codes mod-vars)
  195.       (let ((target (car expr-codes))
  196.         (test (cadr expr-codes)))
  197.         (let loop ((clauses (cddr e))
  198.                (compiled '())
  199.                (mod-vars mod-vars))
  200.           (if (null? clauses)
  201.           (continue
  202.            `(LET ((!SELECT-TARGET ,target)
  203.               (!SELECT-TEST ,test))
  204.               (COND
  205.                ,@(reverse compiled)
  206.                ,@(if Have-Default?
  207.                  '()
  208.                  `((ELSE
  209.                 (DYLAN-CALL DYLAN:ERROR
  210.                         "SELECT -- no match" ',e))))))
  211.            mod-vars)
  212.           (if Have-Default?
  213.               (dylan::error "SELECT -- else isn't last clause" e)
  214.               (compile-clause (car clauses) mod-vars
  215.             (lambda (code mod-vars)
  216.               (loop (cdr clauses)
  217.                 (cons code compiled)
  218.                 mod-vars))))))))))))
  219.  
  220. ;;; FOR
  221.  
  222. (define (compile-FOR-form
  223.      e module-vars bound-vars compiler multiple-values? continue)
  224.   (must-be-list-of-at-least-length e 2 "FOR -- bad syntax")
  225.   (let ((bindings (car e))
  226.     (end-test (cadr e))
  227.     (body (cddr e)))
  228.     (if (or (not (list? bindings))
  229.         (not (all? (lambda (x) (list-of-length? x 3))
  230.                bindings)))
  231.     (dylan::error "FOR -- illegal binding list" e))
  232.     (let ((vars (map (lambda (x)
  233.                (if (not (variable-name? (car x)))
  234.                (dylan::error "FOR -- illegal variable name" x e))
  235.                (variable->name (car x)))
  236.              bindings))
  237.       (inits (map cadr bindings))
  238.       (steps (map caddr bindings)))
  239.       (let ((inner-bound (append vars bound-vars)))
  240.     (compile-forms body module-vars inner-bound compiler #F
  241.       (lambda (body-code module-vars)
  242.         (compile-forms inits module-vars bound-vars compiler #F
  243.           (lambda (init-code module-vars)
  244.         (compile-forms steps module-vars inner-bound compiler #F
  245.           (lambda (step-code module-vars)
  246.             (compile-forms
  247.              end-test module-vars inner-bound
  248.              compiler multiple-values?
  249.              (lambda (end-code module-vars)
  250.                (continue
  251.             `(DO ,(map list vars init-code step-code)
  252.                  ,end-code
  253.                ,@body-code)
  254.             module-vars)))))))))))))
  255.  
  256.